home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d27 / ddsgen.arc / DDSRPF04.RPG < prev    next >
Encoding:
Text File  |  1991-12-04  |  12.1 KB  |  153 lines
  1.      F********************************************************************      
  2.      F*                                                                  *      
  3.      F*  PGMID -        DDS01RPF04                                       *      
  4.      F*                                                                  *      
  5.      F*  FUNCTION -     GENERATE KEY FIELD LEVEL PHYSICAL FILE DDS       *      
  6.      F*                                                                  *      
  7.      F*  AUTHOR -       TERRENCE W. MOYER                                *      
  8.      F*                 55 KEPPEL AVE.                                   *      
  9.      F*                 WEST LAWN, PA. 19609                             *      
  10.      F*                                                                  *      
  11.      F*  DATE -         NOV. 3, 1986                                     *      
  12.      F*                                                                  *      
  13.      F*  INDICATORS -   10  GENERAL PURPOSE, REUSABLE.                   *      
  14.      F*                                                                  *      
  15.      F*  NOTES -                                                         *      
  16.      F*                 SUPPORTED KEYWORDS                               *      
  17.      F*                 DESCEND, ZONE/DIGIT, ABSVAL/UNSIGNED             *      
  18.      F*                 SIGNED (BY DEFAULT).                             *      
  19.      F*                                                                  *      
  20.      F********************************************************************
  21.      FQAFDACCPIF  E                    DISK                           UC        
  22.      FSRCFIL  O   F      92            DISK                      A    UC        
  23.      E                    WRK        68  1               WORK ARRAY             
  24.      E                    WRK1       36  1               DDS FUNCT. FIELD       
  25.      I*  LDA WITH INPUT FILE AND SOURCE FILE INFORMATION                        
  26.      I           UDS                                                            
  27.      I                                        1  10 LINFL                       
  28.      I                                       11  20 LINLB                       
  29.      I                                       21  26 LINDT                       
  30.      I                                       27  32 LINTM                       
  31.      I                                       33  33 LINTYP                      
  32.      I                                       51 100 LINTXT                      
  33.      I                                      101 110 LSRCFL                      
  34.      I                                      111 120 LSRCLB                      
  35.      I                                      121 130 LSRCMB                      
  36.      I                                      201 2062LSRCSQ                      
  37.      I                                      207 2120LSRCDT                      
  38.      I* SOURCE SEQUENCE AND SOURCE DATE DS - WRITTEN TO DDS SRCFILE.            
  39.      I            DS                                                            
  40.      I                                        1   62SRCSEQ
  41.      I                                        7  120SRCDAT                      
  42.      I* DDS SPECIFICATION - TO WRITE ACTUAL SPEC RECORDS TO DDS SRCFILE.        
  43.      IDSPEC       DS                                                            
  44.      I                                        1   5 DBLNK1                      
  45.      I                                        6   6 DSPECA                      
  46.      I                                        7  16 DBLNK2                      
  47.      I                                       17  17 DNMTYP                      
  48.      I                                       18  18 DBLNK3                      
  49.      I                                       19  28 DNAME                       
  50.      I                                       29  29 DREF                        
  51.      I                                       30  34 DLEN                        
  52.      I                                       35  35 DDTYP                       
  53.      I                                       36  37 DDEC                        
  54.      I                                       38  44 DBLNK4                      
  55.      I                                       45  80 DFUNC                       
  56.      I                                        1  80 DSPEC1                      
  57.      I                                        7  80 DSPEC2                      
  58.      C*------------------------------------------------------------------*      
  59.      C*                         MAINLINE                                 *      
  60.      C*------------------------------------------------------------------*
  61.      C* INITIALIZATION AND SETUP.                                               
  62.      C*                                                                         
  63.      C                     Z-ADDLSRCSQ    SRCSEQ           RETRIEVE SRCSEQ      
  64.      C                     Z-ADDLSRCDT    SRCDAT           AND SRCDAT.          
  65.      C                     MOVE 'A'       DSPECA           INIT. SPEC. DS.      
  66.      C*                                                                         
  67.      C                     OPEN SRCFIL                     OPEN FILES.          
  68.      C                     OPEN QAFDACCP                                        
  69.      C                     READ QAFDACCP                 10 GET RECORD.         
  70.      C           APKEYF    IFEQ *BLANK                      NO KEY FIELDS       
  71.      C                     MOVE '1'       *IN10             ACCPTH IS           
  72.      C                     END                              ARRIVAL-EXIT.       
  73.      C*                                                                         
  74.      C*------------------------------------------------------------------*      
  75.      C*                    WRITE KEY LEVEL KEYWORDS.                            
  76.      C*------------------------------------------------------------------*      
  77.      C*  FOR EACH FIELD DO:                                                     
  78.      C           *IN10     DOWEQ'0'                                             
  79.      C*                                                                         
  80.      C*  SETUP KEY FIELD NAME RECORD.                         INIT.
  81.      C                     Z-ADD+0        WFLAG   40       WRITE FLAG           
  82.      C                     MOVE 'K'       DNMTYP           MOVE 'K'             
  83.      C                     MOVE APKEYF    DNAME            MOVE FIELD NAME      
  84.      C*  WRITE SUPPORTED KEYWORDS.                                              
  85.      C           APKSEQ    IFEQ 'D'                        DESCEND DDS          
  86.      C                     MOVEL'DESCEND' DFUNC            KEYWORD.             
  87.      C                     MOVE DSPEC1    LINE   80                             
  88.      C                     EXSR @SRCLN                                          
  89.      C                     MOVE *BLANK    DSPEC2                                
  90.      C                     Z-ADD+1        WFLAG                                 
  91.      C                     END                                                  
  92.      C           APKSIN    IFEQ 'A'                        ABSVAL/UNSIGNED      
  93.      C                     MOVEL'ABSVAL'  DFUNC                                 
  94.      C                     ELSE                                                 
  95.      C           APKSIN    IFEQ 'N'                                             
  96.      C                     MOVEL'UNSIGNED'DFUNC                                 
  97.      C                     END                                                  
  98.      C                     END                                                  
  99.      C           APKSIN    IFNE 'S'                                             
  100.      C                     MOVE DSPEC1    LINE
  101.      C                     EXSR @SRCLN                                          
  102.      C                     MOVE *BLANK    DSPEC2                                
  103.      C                     Z-ADD+1        WFLAG                                 
  104.      C                     END                                                  
  105.      C           APKZD     IFEQ 'Z'                        ZONE/DIGIT           
  106.      C                     MOVEL'ZONE'    DFUNC                                 
  107.      C                     ELSE                                                 
  108.      C           APKZD     IFEQ 'D'                                             
  109.      C                     MOVEL'DIGIT'   DFUNC                                 
  110.      C                     END                                                  
  111.      C                     END                                                  
  112.      C           APKZD     IFNE 'N'                                             
  113.      C                     MOVE DSPEC1    LINE                                  
  114.      C                     EXSR @SRCLN                                          
  115.      C                     MOVE *BLANK    DSPEC2                                
  116.      C                     Z-ADD+1        WFLAG                                 
  117.      C                     END                                                  
  118.      C           WFLAG     IFEQ +0                         NO KEYWORDS          
  119.      C                     MOVE DSPEC1    LINE             SPECIFIED, SO        
  120.      C                     EXSR @SRCLN                     WRITE THE
  121.      C                     MOVE *BLANK    DSPEC2           KEYFIELD             
  122.      C                     END                             RECORD.              
  123.      C*                                                                         
  124.      C                     READ QAFDACCP                 10 GET RECORD.         
  125.      C                     END                             END READ LOOP.       
  126.      C*                                                                         
  127.      C* CLOSE FILES, PASS DATA, AND END PROGRAM.                                
  128.      C*                                                                         
  129.      C                     CLOSEQAFDACCP                                        
  130.      C                     CLOSESRCFIL                                          
  131.      C*                                                                         
  132.      C                     Z-ADDSRCSEQ    LSRCSQ           PASS SRCSEQ          
  133.      C                     Z-ADDSRCDAT    LSRCDT           AND SRCDAT           
  134.      C                     SETON                       LR                       
  135.      C*                                                                         
  136.      C*------------------------------------------------------------------*      
  137.      C*       ADD TO SOURCE SEQUENCE NUMBER AND WRITE AN OUTPUT LINE            
  138.      C*------------------------------------------------------------------*      
  139.      C*                                                                         
  140.      C           @SRCLN    BEGSR
  141.      C*                                                                         
  142.      C                     ADD  +1        SRCSEQ                                
  143.      C                     EXCPTSRCLIN                                          
  144.      C*                                                                         
  145.      C                     ENDSR                                                
  146.      C*------------------------------------------------------------------*      
  147.      C/SPACE 3                                                                  
  148.      OSRCFIL  EADD             SRCLIN                                           
  149.      O                         SRCSEQ     6                                     
  150.      O                         SRCDAT    12                                     
  151.      O                         LINE      92
  152. 
  153.